home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-04
/
uldial.zip
/
ULDIAL.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-07-12
|
20KB
|
649 lines
(***********************************************************************
Dialog Objects as Enhancements to Turbo Power OOP Professional
New Communications Technology, Inc.
Version 2.00
by John Poindexter
July 8, 1990
************************************************************************)
{$I ULDEFINE.INC}
{$IFNDEF dlDEBUG}
{$A-,B-,E+,F+,I+,N-,O+,R-,S-,V-}
{$ELSE}
{$A-,B-,E+,F+,I+,N-,O+,R+,S+,V-}
{$ENDIF}
Unit ULDial;
Interface
Uses OpRoot, OpDos, OpCrt, OpMouse, OpInline, OpString, OpCmd,
OpFrame, OpWindow, OpPick, OpField, OpEntry, OpKey,
ULRoot;
const
(* Status Handler Return Codes *)
scOk = 1;
scCancel = 2;
scRetry = 3;
scTimeOut = 99;
type
HorizVerticalType = (rbHoriz, rbVertical);
var
ButtonFrame : FrameArray;
type
(************************************************************************
RadioButtons is a descendant of PickList
************************************************************************)
RadioButtonsPtr = ^RadioButtons;
RadioButtons = object(PickList)
rbChoices : MStringArrayPtr;
rbOrient : HorizVerticalType;
constructor Init(X1,Y1,X2,Y2: byte; var Colors: ColorSet;
Options: longint; Orientation: HorizVerticalType;
NrRows, NrCols: byte; CharExit: boolean;
CommandHandler: pkGenlProc;
PickOptions: word; Choices: MStringArrayPtr);
destructor Done; virtual;
procedure ItemString(Item: word; Mode: pkMode; var IType: pkItemType;
var IString: string); virtual;
procedure ProcessSelf; virtual;
end;
(************************************************************************
DialogBox displays text, a string entry field and provides radio
buttons for exiting.
************************************************************************)
DialogBoxPtr = ^DialogBox;
DialogBox = object(Root)
dlX1,dlY1,dlX2,dlY2 : word; {Coordinates of Entry Screen}
dlButOrient : HorizVerticalType;
dlNrRows : byte;
dlNrCols : byte;
dlCharExit : boolean;
dlHeader : string[78];
dlHeaderPos : HeaderPosType;
dlText : MStringArrayPtr;
dlChoices : MStringArrayPtr;
dlTNum, dlCNum : byte;
dlOptions : longint;
dlColors : ColorSet;
dlEntry : EntryScreenPtr;
dlButtons : RadioButtonsPtr;
dlPrompt : string;
dlpRow, dlpCol, dlfRow, dlfCol: word;
dlFieldRows : byte;
dlPicture : string;
dlfWidth : word;
dlHelpIndex : word;
dlEditSt: string;
dlTimeOut : longint;
dlLastChoice : word;
dlLastError: word;
dlNumTextLines : byte;
dlTotalTextChars : word;
dlNumChoices : byte;
dlTotalChoiceChars : word;
dlOrientation : pkGenlProc;
constructor Init(ButtonOrientation: HorizVerticalType;
NumTextLines, TotalTextChars,
NumChoices, TotalChoiceChars: word);
constructor InitDeluxe(X1, Y1: word; Options: longint; Colors: ColorSet;
Orientation: HorizVerticalType;
NrRows, NrCols: byte; CharExit: boolean;
NumTextLines, TotalTextChars,
NumChoices, TotalChoiceChars: word);
destructor Done; virtual;
procedure Clear;
function GetLastError: word;
procedure Process; virtual;
procedure AddMessageString(Msg: string);
procedure AddChoiceString(Choice: string);
procedure AddChoice(Choice: string);
procedure AddHeader(S: string; Posn: HeaderPosType);
procedure AddStringEntryField(Prompt: string; pRow, pCol: word;
Picture: string; fRow, fCol: word;
fWidth: byte; HelpIndex: word;
EditSt: string);
function CreateBox: boolean; virtual;
function GetLastChoice: word;
function GetEditedString: string;
procedure SetTimeOut(Delay: word);
end;
(***********************************************************************)
Implementation
(***********************************************************************)
(* RadioButtons Methods *)
constructor RadioButtons.Init(X1,Y1,X2,Y2: byte; var Colors: ColorSet;
Options: longint; Orientation: HorizVerticalType;
NrRows, NrCols: byte; CharExit: boolean;
CommandHandler: pkGenlProc;
PickOptions: word; Choices: MStringArrayPtr);
const
SelColorFlex : FlexAttrs = (0,0,0,0);
SelMonoFlex : FlexAttrs = (0,0,0,0);
UnsColorFlex : FlexAttrs = (0,0,0,0);
UnsMonoFlex : FlexAttrs = (0,0,0,0);
var
Orient : pkGenlProc;
begin
with Colors do
if UseColor then
begin
UnsColorFlex[0] := TextColor;
UnsColorFlex[1] := FlexAHelpColor;
UnsColorFlex[2] := TextColor;
SelColorFlex[0] := TextColor;
SelColorFlex[1] := FlexAHelpColor;
SelColorFlex[2] := SelItemColor;
ProItemColor := TextColor;
end
else
begin
UnsMonoFlex[0] := TextMono;
UnsMonoFlex[1] := FlexAHelpMono;
UnsMonoFlex[2] := TextMono;
SelMonoFlex[0] := TextMono;
SelMonoFlex[1] := FlexAHelpMono;
SelMonoFlex[2] := SelItemMono;
ProItemMono := TextMono;
end;
rbOrient := Orientation;
if Orientation = rbHoriz then Orient := PickSnaking
else Orient := PickVertical;
if not PickList.InitAbstractDeluxe(X1,Y1,X2,Y2,Colors,Options,
Choices^.GetMaxLen+4,
3*Choices^.NumStrings,
Orient,CommandHandler,
PickOptions) then Fail;
if Orientation = rbHoriz then
begin
SetRowLimits(3*NrRows,3*NrRows);
PickCommands.AddCommand(ccUser0, 1, Up, 0);
end
else
begin
PickCommands.AddCommand(ccUser0, 1, Left, 0);
end;
SetPickFlex(pkNormal, True, SelColorFlex, SelMonoFlex);
SetPickFlex(pkNormal, False, UnsColorFlex, UnsMonoFlex);
if CharExit then SetSearchMode(PickCharExit)
else SetSearchMode(PickCharSearch);
rbChoices := Choices;
end;
destructor RadioButtons.Done;
begin
if rbOrient = rbHoriz then
PickCommands.AddCommand(ccUp, 1, Up, 0) {restore normal commands}
else PickCommands.AddCommand(ccLeft, 1, Left, 0);
PickList.Done;
end;
procedure RadioButtons.ItemString(Item: word; Mode: pkMode; var IType: pkItemType;
var IString: string);
var
Which : byte;
Choice : word;
begin
Choice := Pred(Item);
Which := Choice mod 3;
if Which <> 1 then IType := pkProtected;
if Mode = pkGetType then Exit;
Case Which of
0 : IString := ButtonFrame[0]+
CharStr(ButtonFrame[4],rbChoices^.GetMaxLen+2)+
ButtonFrame[2];
1 : begin
IString := rbChoices^.GetString(Choice div 3 + 1);
IString := ButtonFrame[6]+' '+Pad(IString, rbChoices^.GetMaxLen)+
' '+ButtonFrame[7];
Case Mode of
pkDisplay :
begin
Insert(^B, Istring, Length(Istring));
Insert(^B, Istring, 4);
Insert(^A, Istring, 4);
Insert(^A, Istring, 3);
Insert(^B, Istring, 3);
Insert(^B, Istring, 2);
end;
pkSearch : IString := Copy(IString, 3, Length(IString)-4);
end;
end;
2 : IString := ButtonFrame[1]+
CharStr(ButtonFrame[5],rbChoices^.GetMaxLen+2)+
ButtonFrame[3];
end;
end;
procedure RadioButtons.ProcessSelf;
begin
PickList.ProcessSelf;
if (GetLastCommand = ccSelect) or (GetLastcommand = ccMouseSel) then
SetLastCommand(ccDone)
else if GetLastCommand = ccUser0 then SetLastCommand(ccBackTab);
end;
(* DialogBox Methods
dlX1
dlY1┌─────────────────────┐
│ X1 X2 │
│ Y1┌────┐┌────┐ │
│ └────┘└────┘ │
└─────────────────────┘dlY2
dlX2
*)
constructor DialogBox.Init(ButtonOrientation: HorizVerticalType;
NumTextLines, TotalTextChars,
NumChoices, TotalChoiceChars: word);
begin
if not Root.Init then Fail;
dlX1 := 0;
dlY1 := 0;
dlPrompt := '';
dlpRow := 0;
dlpCol := 0;
dlPicture := '';
dlfRow := 0;
dlfCol := 0;
dlFieldRows := 0;
dlfWidth := 0;
dlHelpIndex := hiDialogBox;
dlEditSt := '';
dlLastError := 0;
dlTimeOut := 0;
dlLastChoice := 0;
dlHeader := '';
dlEntry := nil;
dlButtons := nil;
dlOptions := DefWindowOptions+wBordered;
dlColors := ULRootColorSet;
dlButOrient := ButtonOrientation;
dlCharExit := false;
dlNrRows := 1;
dlNrCols := 1;
dlNumTextLines := NumTextLines;
dlTotalTextChars := TotalTextChars;
dlNumChoices := NumChoices;
dlTotalChoiceChars := TotalChoiceChars;
dlText := New(MStringArrayPtr,Init(NumTextLines, TotalTextChars));
dlChoices := New(MStringArrayPtr,Init(NumChoices, TotalChoiceChars));
if (dlText = nil) or (dlChoices = nil) then
begin
if dlText <> nil then Dispose(dlText, Done);
if dlChoices <> nil then Dispose(dlChoices, Done);
Root.Done;
Fail;
end;
end;
constructor DialogBox.InitDeluxe(X1, Y1: word; Options: longint;
Colors: ColorSet;
Orientation: HorizVerticalType;
NrRows, NrCols: byte; CharExit: boolean;
NumTextLines, TotalTextChars,
NumChoices, TotalChoiceChars: word);
begin
if not DialogBox.Init(Orientation, NumTextLines, TotalTextChars, NumChoices,
TotalChoiceChars) then Fail;
dlX1 := X1;
dlY1 := Y1;
dlOptions := Options;
dlColors := Colors;
dlCharExit := CharExit;
dlNrRows := NrRows;
dlNrCols := NrCols;
end;
destructor DialogBox.Done;
begin
if dlEntry <> nil then Dispose(dlEntry, Done); {this also destoys dlButtons}
if dlChoices <> nil then Dispose(dlChoices,Done);
if dlText <> nil then Dispose(dlText,Done);
Root.Done;
end;
procedure DialogBox.Clear;
begin
dlPrompt := '';
dlpRow := 0;
dlpCol := 0;
dlPicture := '';
dlfRow := 0;
dlfCol := 0;
dlFieldRows := 0;
dlfWidth := 0;
dlHelpIndex := 0;
dlEditSt := '';
dlLastError := 0;
dlTimeOut := 0;
dlLastChoice := 0;
dlHeader := '';
if dlEntry <> nil then Dispose(dlEntry, Done); {this also destoys dlButtons}
dlEntry := nil;
dlButtons := nil;
if dlChoices <> nil then Dispose(dlChoices,Done);
if dlText <> nil then Dispose(dlText,Done);
dlText := New(MStringArrayPtr,Init(dlNumTextLines, dlTotalTextChars));
dlChoices := New(MStringArrayPtr,Init(dlNumChoices, dlTotalChoiceChars));
end;
function DialogBox.GetLastError;
begin
GetLastError := dlLastError;
dlLastError := 0;
end;
procedure DialogBox.Process;
var
LastCommand : word;
TimeOut : longint;
begin
if not CreateBox then
begin
SimpStatus(ucULRoot, dlLastError, 'Creation DialogBox failed.');
Halt;
end;
if dlTimeOut <> 0 then
with dlEntry^ do
begin
Draw;
TimeOut := TimeMS + dlTimeOut;
Repeat until KeyPressed or (TimeMS > TimeOut);
if not KeyPressed then
begin
dlLastChoice := scTimeOut;
Exit;
end;
end;
with dlEntry^ do
begin
ClearErrors;
Repeat
Process;
LastCommand := GetLastCommand;
until (LastCommand = ccDone) or (LastCommand = ccError);
Erase;
if LastCommand = ccError then
begin
dlLastError := RawError;
SimpStatus(ucULDial, dlLastError, 'DialogBox problem.');
Abort;
end;
dlLastChoice := (dlButtons^.GetLastChoice - 1) div 3 + 1;
end;
end;
procedure DialogBox.AddMessageString(Msg: string);
var
status : word;
Len : byte absolute Msg;
begin
if Len > (ScreenWidth - 2) then Len := ScreenWidth-2;
status := dlText^.AddMString(Msg);
if status = 0 then dlLastError := ecOutOfMemory;
end;
procedure DialogBox.AddChoiceString(Choice: string);
var
Status : word;
Temp : string;
Len : byte absolute temp;
i : byte;
begin
i := 0;
Len := 1;
while Len <> 0 do
begin
Inc(i);
temp := ExtractWord(i,Choice,[' ']);
if Len <> 0 then status := dlChoices^.AddMString(temp);
end;
if status = 0 then dlLastError := ecOutOfMemory;
end;
procedure DialogBox.AddChoice(Choice: string);
var
status : word;
begin
status := dlChoices^.AddMString(Choice);
if status = 0 then dlLastError := ecOutOfMemory;
end;
procedure DialogBox.AddStringEntryField(Prompt: string; pRow, pCol: word;
Picture: string; fRow, fCol: word;
fWidth: byte; HelpIndex: word;
EditSt: string);
begin
dlPrompt := Prompt;
if pRow = fRow then begin dlpRow := 1; dlfRow := 1; dlFieldRows := 1; end
else if pRow < fRow then begin dlpRow := 1; dlfRow := 2; dlFieldRows := 2; end
else begin dlpRow := 2; dlfRow := 1; dlFieldRows := 2; end;
dlpCol := pCol;
dlfCol := fCol;
dlPicture := Picture;
dlfWidth := fWidth;
dlHelpIndex := HelpIndex;
dlEditSt := EditSt;
end;
function DialogBox.CreateBox: boolean;
var
X1,Y1,X2,Y2 : byte; {coordinates of RadioButtons}
Xs, Ys : byte; {save desired location of EntryScreen}
WWidth, Twidth, Cwidth, Pwidth, Fwidth : word;
WHeight, THeight, PHeight : word;
status : word;
i : integer;
Line : string;
Len : byte absolute Line;
begin
CreateBox := false;
if (dlEntry <> nil) and (dlButtons <> nil) then
begin
CreateBox := true;
Exit;
end;
{ Check to see if called by InitDeluxe }
if dlX1 <> 0 then
begin
Xs := dlX1;
Ys := dlY1;
end
else Xs := 0;
WWidth := ScreenWidth - 2;
WHeight := ScreenHeight - 2;
Twidth := dlText^.GetMaxLen;
dlTNum := dlText^.NumStrings;
dlCNum := dlChoices^.NumStrings;
if (dlCNum = 0) then
begin
dlLastError := epFatal+ecNoChoice;
Exit;
end;
Cwidth := dlChoices^.GetMaxLen + 4;
{ Calculate dimensions }
{ If there is a string field calcualte total width }
if dlFieldRows > 0 then
begin
if dlpRow = dlfRow then
begin
Fwidth := dlfCol+dlfWidth-1;
if Fwidth > Wwidth then
begin
dlfWidth := Wwidth - dlfCol + 1;
Fwidth := Wwidth;
end;
end
else Fwidth := MaxWord(dlpCol+Length(dlPrompt)-1, dlfCol+dlfWidth-1);
end
else Fwidth := 0;
{ Calculate for horizontal or vertical radio buttons }
if dlButOrient = rbHoriz then
begin
if dlNrCols < 2 then Pwidth := (dlCNum div dlNrRows) * Cwidth
else Pwidth := dlNrCols * Cwidth;
Pwidth := MinWord(WWidth, PWidth);
PHeight := 3 * dlNrRows;
Twidth := MinWord(WWidth, Twidth);
if dlTnum + PHeight + dlFieldRows > WHeight
then dlTnum := WHeight - PHeight - dlFieldRows
else WHeight := dlTNum + PHeight + dlFieldRows;
Twidth := MaxWord(Pwidth, Twidth);
{ at this point Pwidth & PHeight are dimensions of RadioButton window
and Twidth & WHeight are dimensions of EntryScreen window }
{ If there is a StringEntryField then, calculate widest.}
WWidth := MaxWord(FWidth, Twidth);
{ at this point WWidth & WHeight are dimensions of EntryScreen window }
dlX1 := Center1(ScreenWidth,WWidth);
dlY1 := Center1(ScreenHeight,WHeight);
if Xs > 0 then
begin
dlX1 := GetGoodCoord(Xs,WWidth,ScreenWidth-2);
dlY1 := GetGoodCoord(Ys,WHeight,ScreenHeight-2);
end;
dlX2 := Coord2(dlX1,WWidth);
dlY2 := Coord2(dlY1,WHeight);
X1 := dlX1 + (WWidth-Pwidth) div 2;
X2 := Coord2(X1,PWidth);
Y1 := dlY2 - PHeight + 1;
Y2 := dlY2;
end
else {radio buttons are vertical }
begin
PWidth := dlNrCols * Cwidth;
if Pwidth > WWidth then
repeat
Dec(dlNrCols);
PWidth := dlNrCols * Cwidth;
until PWidth <= WWidth;
if dlNrRows < 2 then PHeight := (dlCnum div dlNrCols) * 3
else PHeight := dlNrRows * 3;
if (PHeight + dlFieldRows) > WHeight then PHeight := WHeight - dlFieldRows;
Twidth := MinWord(Twidth, Wwidth-Pwidth);
THeight := dlTnum + dlFieldRows;
if THeight > WHeight then
begin
dlTnum := WHeight - dlFieldRows;
THeight := dlTNum + dlFieldRows;
end;
WHeight := MaxWord(PHeight, THeight);
if dlFieldRows > 0 then
begin
if WHeight = PHeight then
begin
Fwidth := MinWord(Fwidth, Wwidth-Pwidth);
if dlpRow = dlfRow then
dlfWidth := MinWord(dlfWidth, Fwidth-dlfCol+1);
end;
end;
WWidth := MaxWord(FWidth+Pwidth, Twidth+PWidth);
dlX1 := Center1(ScreenWidth,WWidth);
dlY1 := Center1(ScreenHeight,WHeight);
if Xs > 0 then
begin
dlX1 := GetGoodCoord(Xs,WWidth,ScreenWidth-2);
dlY1 := GetGoodCoord(Ys,WHeight,ScreenHeight-2);
end;
dlX2 := Coord2(dlX1,WWidth);
dlY2 := Coord2(dlY1,WHeight);
X1 := dlX2 - PWidth + 1;
X2 := dlX2;
Y1 := dlY1;
Y2 := Y1 + PHeight - 1;
end;
if (dlFieldRows <> 0) and (dlButOrient = rbHoriz) then
begin
if (Fwidth < WWidth) then
begin
Twidth := (WWidth - Fwidth) div 2;
dlpCol := dlpCol + Twidth;
dlfCol := dlfCol + Twidth;
end;
end;
dlButtons := New(RadioButtonsPtr,Init(X1,Y1,X2,Y2,dlColors,
wClear+wNoCoversBuffer, dlButOrient, dlNrRows,dlNrCols,
dlCharExit, SingleChoice, DefPickOptions-pkStick, dlChoices));
if dlButtons = nil then Exit;
dlEntry := New(EntryScreenPtr, InitCustom(dlX1,dlY1,dlX2,dlY2,
dlColors, dlOptions));
if dlEntry = nil then Exit;
{$IFDEF UseMouse}
if MouseInstalled then
begin
PickCommands.cpOptionsOn(cpEnableMouse);
EntryCommands.cpOptionsOn(cpEnableMouse);
MouseGotoXY(X1+1,Y1+1);
end;
{$ENDIF}
dlButtons^.SetErrorProc(SimpStatus);
with dlEntry^ do
begin
SetErrorProc(SimpStatus);
if dlHeader <> '' then wFrame.AddHeader(dlHeader, dlHeaderPos);
if (dlOptions and wBordered) = wBordered
then wFrame.AddShadow(shBR, shSeeThru);
for i := 1 to dlTNum do
begin
Line := dlText^.GetStringPtr(i)^;
if dlButOrient = rbHoriz then Line := Center(Line,WWidth);
AddTextField(Line,i,1);
end;
if dlFieldRows > 0 then
begin
esFieldOptionsOff(efAutoAdvance);
AddStringField(dlPrompt,dlTNum+dlpRow,dlpCol,dlPicture,
dlTNum+dlfRow,dlfCol,dlfWidth,
dlHelpIndex,dlEditSt);
end;
{ add in radio buttons }
X1 := X1 - dlX1 + 1;
Y1 := Y1 - dlY1 + 1;
AddWindowField('',Y1,X1,Y1,X1, dlHelpIndex, dlButtons^);
dlLastError := RawError;
if dlLastError <> 0 then Exit;
end;
CreateBox := true;
end;
procedure DialogBox.AddHeader(S: string; Posn: HeaderPosType);
begin
dlHeaderPos := Posn;
dlHeader := S;
end;
function DialogBox.GetLastChoice: word;
begin
GetLastChoice := dlLastChoice;
end;
function DialogBox.GetEditedString: string;
begin
GetEditedString := dlEditSt;
end;
procedure DialogBox.SetTimeOut(Delay: word);
begin
dlTimeOut := longint(1000*Delay);
end;
(***************************)
{Initialization}
begin
ButtonFrame := SglWindowFrame;
end.